home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-03 / imb9008.zip / WRITEDBF.BAS < prev   
BASIC Source File  |  1990-07-12  |  9KB  |  316 lines
  1. DEFINT A-Z
  2.  
  3. DECLARE FUNCTION ReadDbfHdr% ()
  4. DECLARE FUNCTION ReadFileStructure% ()
  5. DECLARE FUNCTION RightJust$ (Value$, FieldWidth%)
  6. DECLARE FUNCTION ZeroJust$ (Number AS INTEGER)
  7.  
  8. DECLARE SUB DspDbfInfo ()
  9. DECLARE SUB InputRecord (R$())
  10. DECLARE SUB Pause ()
  11. DECLARE SUB WriteRecord (R$(), AppendingRecordFlag%)
  12.  
  13. '=================================================
  14. '=   PROGRAM: WriteDBF.BAS                       =
  15. '=   PURPOSE: Write records to dBASE III+/IV     =
  16. '=            DBF files                          =
  17. '=================================================
  18.  
  19. '-------------------------------------------------
  20. ' Initialize variables and create types          -
  21. '-------------------------------------------------
  22.  
  23. CONST True = -1, False = 0
  24.  
  25. TYPE HeaderInfoType
  26.   VersionNumber AS INTEGER
  27.   LastUpdate    AS STRING * 8
  28.   NumberRecords AS LONG
  29.   HeaderLength  AS INTEGER
  30.   RecordLength  AS INTEGER
  31.   NumberFields  AS INTEGER
  32.   FileSize      AS LONG
  33. END TYPE
  34.  
  35. TYPE FieldInfoType
  36.   FdName   AS STRING * 11
  37.   FdType   AS STRING * 1
  38.   FdLength AS INTEGER
  39.   FdDec    AS INTEGER
  40. END TYPE
  41.  
  42. DIM SHARED Hdr AS HeaderInfoType
  43. DIM SHARED FileName$
  44.  
  45. '-------------------------------------------------
  46. '  Main processing loop                          -
  47. '-------------------------------------------------
  48.  
  49.   FileName$ = "PLANETS.DBF"
  50.   OPEN FileName$ FOR BINARY AS #1
  51.   CLS
  52.   ActionHdr = ReadDbfHdr
  53.   SELECT CASE ActionHdr
  54.     CASE 1
  55.       BEEP
  56.       PRINT "Not a dBASE III+ or IV file"
  57.     CASE ELSE
  58.       DspDbfInfo
  59.       Pause
  60.       DIM SHARED Flds(Hdr.NumberFields) AS FieldInfoType
  61.       ActionFile = ReadFileStructure
  62.       SELECT CASE ActionFile
  63.         CASE True
  64.           DIM SHARED NewData$(Hdr.NumberFields)
  65.           Response$ = ""
  66.           RecNbr = Hdr.NumberRecords
  67.           DO WHILE UCASE$(Response$) <> "N"
  68.             CLS
  69.             INPUT "Append record to file (Y/N)"; Response$
  70.             IF UCASE$(Response$) = "Y" THEN
  71.               RecNbr = RecNbr + 1 'Append Record
  72.               CALL InputRecord(NewData$())
  73.               CALL WriteRecord(NewData$(), RecNbr)
  74.               ActionHdr = ReadDbfHdr
  75.               DspDbfInfo
  76.               Pause
  77.             END IF
  78.           LOOP
  79.         CASE False
  80.           BEEP
  81.           PRINT "Field information error"
  82.       END SELECT
  83.    END SELECT
  84.    PRINT "DBF closed"
  85.    CLOSE #1
  86.    END
  87.  
  88. SUB DspDbfInfo
  89.   
  90. '-------------------------------------------------
  91. 'Display dBASE file header information           -
  92. '-------------------------------------------------
  93.  
  94. PRINT USING "dBASE Version         : #"; Hdr.VersionNumber
  95. PRINT "Database in use       : "; FileName$
  96. PRINT USING "Number of data records: ########"; Hdr.NumberRecords
  97. PRINT "Date of last update   : "; Hdr.LastUpdate
  98. PRINT USING "Header length         :     ####"; Hdr.HeaderLength
  99. PRINT USING "Record length         :     ####"; Hdr.RecordLength
  100. PRINT USING "Number of fields      :      ###"; Hdr.NumberFields
  101. PRINT USING "File size             : ########"; Hdr.FileSize
  102.  
  103. END SUB
  104.  
  105. SUB InputRecord (R$())
  106. '-------------------------------------------------
  107. 'Prompt user to input all fields for a record    -
  108. '-------------------------------------------------
  109.  
  110. CLS
  111.  
  112. LOCATE 1, 35: PRINT "Enter Records": PRINT
  113.  
  114. PRINT "Field Name    Type                Length";
  115. PRINT "  Decimals  - Enter Value"
  116. PRINT
  117. Fmt1$ = "\        \   \                \"
  118. Fmt2$ = "    ###      ##       <"
  119. FOR I = 1 TO UBOUND(R$)
  120.  
  121.   IF Flds(I).FdType <> "M" THEN
  122.     ExtraOffset = 0
  123.     SELECT CASE Flds(I).FdType
  124.       CASE "C"
  125.         PromptType$ = "Character"
  126.       CASE "N"
  127.         PromptType$ = "Numeric"
  128.       CASE "F"
  129.         PromptType$ = "Floating Point"
  130.       CASE "L"
  131.         PromptType$ = "Logical"
  132.       CASE "D"
  133.         PromptType$ = "Date (YYYY/MM/DD)"
  134.         ExtraOffset = 2
  135.       CASE ELSE
  136.     END SELECT
  137.  
  138.     PRINT USING Fmt1$; Flds(I).FdName; PromptType$;
  139.     PRINT USING Fmt2$; Flds(I).FdLength; Flds(I).FdDec;
  140.  
  141.     PRINT SPACE$(Flds(I).FdLength + ExtraOffset); ">";
  142.     LOCATE , POS(0) - Flds(I).FdLength - 1 - ExtraOffset
  143.     INPUT "", R$(I)
  144.   END IF
  145. NEXT I
  146. END SUB
  147.  
  148. SUB Pause
  149.  
  150. '-------------------------------------------------
  151. 'Prompt user to press a key to continue          -
  152. '-------------------------------------------------
  153.  
  154.   PRINT
  155.   PRINT "Press any key to continue"
  156.   WHILE INKEY$ = "": WEND
  157. END SUB
  158.  
  159. FUNCTION ReadDbfHdr
  160.  
  161. '-------------------------------------------------
  162. 'Purpose: Read the dBASE file header information -
  163. '         and store in the header record         -                                        -
  164. '-------------------------------------------------
  165.  
  166. HdrStr$ = SPACE$(32)
  167. GET #1, 1, HdrStr$              'Read dBASE Header
  168.  
  169. Hdr.VersionNumber = ASC(LEFT$(HdrStr$, 1)) AND (7)
  170.  
  171. UpdYY$ = ZeroJust$(ASC(MID$(HdrStr$, 2, 1)))
  172. UpdMM$ = ZeroJust$(ASC(MID$(HdrStr$, 3, 1)))
  173. UpdDD$ = ZeroJust$(ASC(MID$(HdrStr$, 4, 1)))
  174.  
  175. Hdr.LastUpdate = UpdMM$ + "/" + UpdDD$ + "/" + UpdYY$
  176.  
  177. Hdr.NumberRecords = CVL(MID$(HdrStr$, 5, 4))
  178. Hdr.HeaderLength = CVI(MID$(HdrStr$, 9, 2))
  179. Hdr.RecordLength = CVI(MID$(HdrStr$, 11, 2))
  180.  
  181. Hdr.NumberFields = (Hdr.HeaderLength - 33) / 32
  182. DataSize = Hdr.RecordLength * Hdr.NumberRecords + 1
  183. Hdr.FileSize = Hdr.HeaderLength + DataSize
  184.  
  185. IF Hdr.VersionNumber <> 3 THEN
  186.    ReadDbfHdr = 1                'Not a dBASE file
  187.    EXIT FUNCTION
  188. END IF
  189.  
  190. IF Hdr.NumberRecords = 0 THEN
  191.    ReadDbfHdr = 2                'No records
  192.    EXIT FUNCTION
  193. END IF
  194. ReadDbfHdr = 0                   'No errors
  195. END FUNCTION
  196.  
  197. FUNCTION ReadFileStructure
  198.   
  199. '-------------------------------------------------
  200. 'Purpose: Read the file structure store in the   -
  201. '         dBASE file header.                     -
  202. '-------------------------------------------------
  203.  
  204. FOR I = 1 TO Hdr.NumberFields
  205.    Fld$ = SPACE$(32)
  206.    GET #1, , Fld$           'Get field info string
  207.    Flds(I).FdName = LEFT$(Fld$, 11)
  208.    Flds(I).FdType = MID$(Fld$, 12, 1)
  209.    Flds(I).FdLength = ASC(MID$(Fld$, 17, 1))
  210.    Flds(I).FdDec = ASC(MID$(Fld$, 18, 1))
  211. NEXT I
  212. HeaderTerminator$ = INPUT$(1, #1)   'Last hdr byte
  213. IF ASC(HeaderTerminator$) <> 13 THEN
  214.    ReadFileStructure = False       'Bad Dbf header
  215. END IF
  216. ReadFileStructure = True
  217. END FUNCTION
  218.  
  219. FUNCTION RightJust$ (Value$, FldWidth)
  220.   
  221. '-------------------------------------------------
  222. 'Purpose: Right justify a string by padding it   -
  223. '         with spaces on the left                -
  224. 'Input  : The character value to justify, the    -
  225. '         width of the field to fit              -
  226. 'Output : A right justified string to print      -
  227. '-------------------------------------------------
  228.  
  229. RightJust$ = RIGHT$(STRING$(FldWidth, " ") + Value$, FldWidth)
  230. END FUNCTION
  231.  
  232. SUB WriteRecord (R$(), RecNbr)
  233.  
  234. '-------------------------------------------------
  235. 'Purpose: Write record to DBF file               -
  236. 'Input  : String array of field contents, R$()   -
  237. '         Record number to write, RecNbr         -
  238. '         Appends record to file if greater than -
  239. '         number of records currently in file    -
  240. '-------------------------------------------------
  241.  
  242.   IF RecNbr > Hdr.NumberRecords THEN 'Appending rec
  243.     Offset = (Hdr.NumberRecords) * Hdr.RecordLength
  244.     RecPos = Offset + Hdr.HeaderLength + 1
  245.     Hdr.NumberRecords = Hdr.NumberRecords + 1
  246.     NR$ = MKL$(Hdr.NumberRecords)
  247.     PUT #1, 5, NR$
  248.     Appending = True
  249.   ELSE
  250.     Offset = (RecNbr - 1) * Hdr.RecordLength
  251.     RecPos = Offset + Hdr.HeaderLength + 1
  252.     Appending = False
  253.   END IF
  254.  
  255.   EOFchr$ = CHR$(26)  'Set End of File character
  256.  
  257.   R$(0) = " " 'Init to 1 space for the status flag
  258.   PUT #1, RecPos, R$(0)
  259.  
  260.   FOR I = 1 TO UBOUND(R$)
  261.  
  262.     IF Flds(I).FdType = "D" THEN
  263.       R$(I) = LEFT$(R$(I), 4) + MID$(R$(I), 6, 2)
  264.       R$(I) = R$(I) + RIGHT$(R$(I), 2)
  265.     END IF
  266.     'If Larger than field width
  267.     IF LEN(R$(I)) > Flds(I).FdLength THEN
  268.       R$(I) = LEFT$(R$(I), Flds(I).FdLength)
  269.     ELSEIF LEN(R$(I)) < Flds(I).FdLength THEN
  270.       IF INSTR("NF", Flds(I).FdType) <> 0 THEN
  271.         ' Right justify numbers
  272.         R$(I) = RightJust$(R$(I), Flds(I).FdLength)
  273.       ELSE
  274.         'Else left justify all other field types
  275.         R$(I) = R$(I) + SPACE$(Flds(I).FdLength - LEN(R$(I)))
  276.       END IF
  277.     END IF
  278.  
  279.     PUT #1, , R$(I)
  280.  
  281.   NEXT I
  282.  
  283.  
  284.   IF Appending THEN 'Add End of record marker
  285.     PUT #1, , EOFchr$
  286.   END IF
  287.  
  288.   D$ = DATE$
  289.   UpdYY$ = CHR$(VAL(RIGHT$(D$, 2)))
  290.   PUT #1, 2, UpdYY$
  291.   UpdMM$ = CHR$(VAL(LEFT$(D$, 2)))
  292.   PUT #1, 3, UpdMM$
  293.   UpdDD$ = CHR$(VAL(MID$(D$, 4, 2)))
  294.   PUT #1, 4, UpdDD$
  295.   PRINT : PRINT "Record written and file updated"
  296.   PRINT
  297. END SUB
  298.  
  299. DEFSNG A-Z
  300. FUNCTION ZeroJust$ (Number AS INTEGER)
  301.   
  302. '-------------------------------------------------
  303. 'Purpose: Add a leading zero to numbers less     -
  304. '         than 10 so they take as much room as   -
  305. '         numbers 10 and larger                  -
  306. 'Input  : The number to standardize              -
  307. 'Output : The adjusted number                    -
  308. '-------------------------------------------------
  309.  
  310. N$ = STR$(Number)
  311. LengthN = LEN(N$) - 1'Subtract 1 for leading space
  312. N$ = RIGHT$("0" + RIGHT$(N$, LengthN), 2)
  313. ZeroJust$ = N$
  314. END FUNCTION
  315.  
  316.